Planet Source Code Jumbo …e CD Visual Basic 1 to 7/3_2004-2005.ISO/Data/Zips/Program_La1759096192004.psc/program launcher/frmMain.frm

Text File | 2004-06-18 | 23KB | 697 lines

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "mscomctl.ocx"
Begin VB.Form frmMain
   Appearance      =   0  'Flat
   BackColor       =   &H00C0C0C0&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Program Launcher"
   ClientHeight    =   3945
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   6390
   BeginProperty Font
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "frmMain.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3945
   ScaleWidth      =   6390
   Begin VB.Timer Timer1
      Interval        =   100
      Left            =   2640
      Top             =   1770
   End
   Begin VB.PictureBox Picture1
      AutoSize        =   -1  'True
      BackColor       =   &H00FF0000&
      Height          =   3705
      Left            =   150
      ScaleHeight     =   3645
      ScaleWidth      =   6105
      TabIndex        =   15
      Top             =   150
      Width           =   6165
      Begin VB.OptionButton optPredefined
         BackColor       =   &H00E0E0E0&
         Caption         =   "Predefined"
         ForeColor       =   &H00000000&
         Height          =   285
         Left            =   4890
         Style           =   1  'Graphical
         TabIndex        =   26
         Top             =   2370
         Visible         =   0   'False
         Width           =   1095
      End
      Begin VB.OptionButton optUser
         Caption         =   "User Defined"
         Height          =   285
         Left            =   3750
         Style           =   1  'Graphical
         TabIndex        =   25
         Top             =   2370
         Value           =   -1  'True
         Visible         =   0   'False
         Width           =   1095
      End
      Begin VB.CheckBox chkWin
         Appearance      =   0  'Flat
         BackColor       =   &H00E0E0E0&
         Caption         =   "Win"
         ForeColor       =   &H00000000&
         Height          =   315
         Left            =   1140
         Style           =   1  'Graphical
         TabIndex        =   4
         Top             =   2760
         Width           =   675
      End
      Begin VB.CommandButton cmdFolder
         Appearance      =   0  'Flat
         BackColor       =   &H00E0E0E0&
         Height          =   345
         Left            =   540
         MaskColor       =   &H80000005&
         Picture         =   "frmMain.frx":030A
         Style           =   1  'Graphical
         TabIndex        =   3
         ToolTipText     =   " Select target folder... "
         Top             =   2730
         Width           =   345
      End
      Begin VB.TextBox txtFileName
         BackColor       =   &H00FF0000&
         BorderStyle     =   0  'None
         ForeColor       =   &H00FFFFFF&
         Height          =   285
         Left            =   210
         Locked          =   -1  'True
         TabIndex        =   1
         Top             =   2400
         Width           =   5685
      End
      Begin VB.CommandButton cmdFile
         Appearance      =   0  'Flat
         BackColor       =   &H00E0E0E0&
         Height          =   345
         Left            =   150
         MaskColor       =   &H80000005&
         Picture         =   "frmMain.frx":7EEC
         Style           =   1  'Graphical
         TabIndex        =   2
         ToolTipText     =   " Select target file... "
         Top             =   2730
         Width           =   345
      End
      Begin VB.CommandButton cmdHelp
         Appearance      =   0  'Flat
         BackColor       =   &H00E0E0E0&
         Caption         =   "&Help"
         Height          =   315
         Left            =   4080
         MaskColor       =   &H80000005&
         Style           =   1  'Graphical
         TabIndex        =   13
         ToolTipText     =   " About Program Launcher, Usage and Error Lookup "
         Top             =   3240
         Width           =   945
      End
      Begin VB.CommandButton cmdLaunch
         Appearance      =   0  'Flat
         BackColor       =   &H00E0E0E0&
         Caption         =   "&Launch"
         Height          =   315
         Left            =   2100
         MaskColor       =   &H80000005&
         Style           =   1  'Graphical
         TabIndex        =   11
         ToolTipText     =   " Launch selected file "
         Top             =   3240
         Width           =   945
      End
      Begin MSComctlLib.ListView lstvwPrograms
         Height          =   2085
         Left            =   120
         TabIndex        =   0
         Top             =   120
         Width           =   5865
         _ExtentX        =   10345
         _ExtentY        =   3678
         View            =   3
         LabelEdit       =   1
         LabelWrap       =   -1  'True
         HideSelection   =   0   'False
         FullRowSelect   =   -1  'True
         _Version        =   393217
         ForeColor       =   16777215
         BackColor       =   16711680
         Appearance      =   0
         NumItems        =   0
      End
      Begin VB.CommandButton cmdClose
         Appearance      =   0  'Flat
         BackColor       =   &H00E0E0E0&
         Caption         =   "&Exit"
         Height          =   315
         Left            =   5070
         MaskColor       =   &H80000005&
         Style           =   1  'Graphical
         TabIndex        =   14
         ToolTipText     =   " Stop using Program Launcher "
         Top             =   3240
         Width           =   945
      End
      Begin VB.PictureBox picTray
         BackColor       =   &H00FF0000&
         BorderStyle     =   0  'None
         Height          =   480
         Left            =   5430
         Picture         =   "frmMain.frx":9BE6
         ScaleHeight     =   480
         ScaleWidth      =   450
         TabIndex        =   19
         Top             =   2730
         Width           =   450
      End
      Begin VB.CommandButton cmdHide
         Appearance      =   0  'Flat
         BackColor       =   &H00E0E0E0&
         Cancel          =   -1  'True
         Caption         =   "Hi&de"
         Height          =   315
         Left            =   3090
         MaskColor       =   &H80000005&
         Style           =   1  'Graphical
         TabIndex        =   12
         ToolTipText     =   " Hide Program Launcher (Press Win+A to make visible) "
         Top             =   3240
         Width           =   945
      End
      Begin VB.CommandButton cmdDelete
         Appearance      =   0  'Flat
         BackColor       =   &H00E0E0E0&
         Caption         =   "&Remove"
         Height          =   315
         Left            =   1110
         MaskColor       =   &H80000005&
         Style           =   1  'Graphical
         TabIndex        =   10
         ToolTipText     =   " Delete selected shortcut "
         Top             =   3240
         Width           =   945
      End
      Begin VB.CheckBox chkCtrl
         Appearance      =   0  'Flat
         BackColor       =   &H00E0E0E0&
         Caption         =   "Ctrl"
         ForeColor       =   &H00000000&
         Height          =   315
         Left            =   2010
         Style           =   1  'Graphical
         TabIndex        =   5
         Top             =   2760
         Width           =   675
      End
      Begin VB.CheckBox chkShift
         Appearance      =   0  'Flat
         BackColor       =   &H00E0E0E0&
         Caption         =   "Shift"
         ForeColor       =   &H00000000&
         Height          =   315
         Left            =   2880
         Style           =   1  'Graphical
         TabIndex        =   6
         Top             =   2760
         Width           =   675
      End
      Begin VB.CheckBox chkAlt
         Appearance      =   0  'Flat
         BackColor       =   &H00E0E0E0&
         Caption         =   "Alt"
         ForeColor       =   &H00000000&
         Height          =   315
         Left            =   3750
         Style           =   1  'Graphical
         TabIndex        =   7
         Top             =   2760
         Width           =   675
      End
      Begin VB.ComboBox cmbKey
         BackColor       =   &H00E0E0E0&
         ForeColor       =   &H00000000&
         Height          =   315
         Left            =   4620
         Style           =   2  'Dropdown List
         TabIndex        =   8
         Top             =   2760
         Width           =   735
      End
      Begin MSComDlg.CommonDialog CommonDialog1
         Left            =   5010
         Top             =   300
         _ExtentX        =   847
         _ExtentY        =   847
         _Version        =   393216
      End
      Begin VB.CommandButton cmdSave
         Appearance      =   0  'Flat
         BackColor       =   &H00E0E0E0&
         Caption         =   "&Save"
         Height          =   315
         Left            =   120
         MaskColor       =   &H80000005&
         Style           =   1  'Graphical
         TabIndex        =   9
         ToolTipText     =   " Save shortcut "
         Top             =   3240
         Width           =   945
      End
      Begin VB.Label Label4
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "+"
         ForeColor       =   &H00FFFFFF&
         Height          =   195
         Left            =   1860
         TabIndex        =   24
         Top             =   2820
         Width           =   120
      End
      Begin VB.Label Label1
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "+"
         ForeColor       =   &H00FFFFFF&
         Height          =   195
         Left            =   2730
         TabIndex        =   18
         Top             =   2820
         Width           =   120
      End
      Begin VB.Label Label2
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "+"
         ForeColor       =   &H00FFFFFF&
         Height          =   195
         Left            =   4470
         TabIndex        =   17
         Top             =   2820
         Width           =   120
      End
      Begin VB.Label Label3
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "+"
         ForeColor       =   &H00FFFFFF&
         Height          =   195
         Left            =   3600
         TabIndex        =   16
         Top             =   2820
         Width           =   120
      End
   End
   Begin VB.Label Label9
      BackColor       =   &H00404040&
      Height          =   15
      Left            =   0
      TabIndex        =   23
      Top             =   4005
      Width           =   6825
   End
   Begin VB.Label Label8
      BackColor       =   &H00E0E0E0&
      Height          =   15
      Left            =   -60
      TabIndex        =   22
      Top             =   0
      Width           =   6735
   End
   Begin VB.Label Label7
      BackColor       =   &H00404040&
      Height          =   4215
      Left            =   6465
      TabIndex        =   21
      Top             =   -30
      Width           =   15
   End
   Begin VB.Label Label6
      BackColor       =   &H00E0E0E0&
      Height          =   4005
      Left            =   0
      TabIndex        =   20
      Top             =   0
      Width           =   15
   End
   Begin VB.Menu mnuMenus
      Caption         =   "Main Menus"
      Visible         =   0   'False
      Begin VB.Menu mnuProgList
         Caption         =   "Show Program List"
      End
      Begin VB.Menu mnuActivate
         Caption         =   "Activate when Windows starts"
      End
      Begin VB.Menu d1
         Caption         =   "-"
      End
      Begin VB.Menu mnuExit
         Caption         =   "Exit"
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim blnDrag As Boolean
Dim lTop As Long, lLeft As Long
Dim intIndex As Long
Dim strF As String

Private Sub chkCtrl_Click()
    chkCtrl.FontBold = chkCtrl.Value
End Sub

Private Sub chkShift_Click()
    chkShift.FontBold = chkShift.Value
End Sub

Private Sub chkAlt_Click()
    chkAlt.FontBold = chkAlt.Value
End Sub

Private Sub chkWin_Click()
    chkWin.FontBold = chkWin.Value
End Sub

Private Sub cmdFile_Click()
On Error GoTo Err1
    CommonDialog1.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly
    CommonDialog1.CancelError = True
    CommonDialog1.Filter = "All files (*.*)|*.*" 'displays all files
    CommonDialog1.DialogTitle = "Select Target file"
    CommonDialog1.ShowOpen
    txtFileName.Text = CommonDialog1.FileName
    strF = "I"
    Exit Sub
Err1:
End Sub

Public Sub cmdClose_Click()
    prcCloseProgram
End Sub

Private Sub cmdDelete_Click()
Dim intRecNo As Integer
Dim lRet As Long

    Picture1.SetFocus
    frmConfirm.Show vbModal
    If blnRemoveHotKey = False Then Exit Sub
    intRecNo = 1

    lRet = UnregisterHotKey(frmIcon.hwnd, lstvwPrograms.SelectedItem.Index)
    Kill strDataFile 'delete data file
    lstvwPrograms.ListItems.Remove lstvwPrograms.SelectedItem.Index 'remove selected item
    prcWrite 're-write the data file
    prcUnregisterAll
    prcRegisterAll
End Sub

Private Sub cmdHelp_Click()
    Picture1.SetFocus
    frmHelp.Show vbModal
End Sub

Private Sub cmdHide_Click()
    Picture1.SetFocus
    Unload Me
    Set frmMain = Nothing
End Sub

Private Sub cmdLaunch_Click()
    Picture1.SetFocus
    If Not lstvwPrograms.SelectedItem Is Nothing Then
        prcLaunch lstvwPrograms.SelectedItem.ListSubItems(1).Text & "\" & lstvwPrograms.SelectedItem.Text
    End If
End Sub

Private Sub cmdSave_Click()
Dim lRet As Long
Dim vModifierKey
Dim lstItem As ListItem
Dim bSave As Boolean
Dim sKeys As String

    Picture1.SetFocus
    If txtFileName.Text = "" Then
        prcShowMsg "Select Target File name"
        cmdFile_Click
        Exit Sub
    ElseIf Dir(txtFileName.Text, vbDirectory + vbNormal) = "" Then
        prcShowMsg "Target file/folder not found" '
        Exit Sub
    ElseIf chkWin.Value = 0 And chkAlt.Value = 0 And chkShift.Value = 0 And chkCtrl.Value = 0 Then
        prcShowMsg "Select a system key"
        Exit Sub
    ElseIf cmbKey.Text = "" Then
        prcShowMsg "Select a key"
        cmbKey.SetFocus
        Exit Sub
    End If

    If chkWin.Value = 1 Then sKeys = "Win"
    If chkCtrl.Value = 1 Then sKeys = IIf(sKeys = "", "Ctrl", sKeys & "+Ctrl")
    If chkShift.Value = 1 Then sKeys = IIf(sKeys = "", "Shift", sKeys & "+Shift")
    If chkAlt.Value = 1 Then sKeys = IIf(sKeys = "", "Alt", sKeys & "+Alt")
    sKeys = sKeys & "+" & cmbKey.Text

    With lstvwPrograms.ListItems
        For lRet = 1 To .Count
            vModifierKey = UCase(.Item(lRet).ListSubItems(2).Text)
            If UCase(sKeys) = vModifierKey Then
                prcShowMsg "Selected combination of keys is already assigned to " & vbCrLf & "'" & .Item(lRet).ListSubItems(1).Text & "\" & .Item(lRet).Text & "'"
                Exit Sub
            End If
        Next
    End With

    vModifierKey = ""
    If chkWin.Value = 1 Then vModifierKey = MOD_WIN
    If chkCtrl.Value = 1 Then vModifierKey = vModifierKey + MOD_CONTROL
    If chkShift.Value = 1 Then vModifierKey = vModifierKey + MOD_SHIFT
    If chkAlt.Value = 1 Then vModifierKey = vModifierKey + MOD_ALT

    With objPLKeys
        .pKeyWin = IIf(chkWin.Value, MOD_WIN, 0)
        .pKeyAlt = IIf(chkAlt.Value, MOD_ALT, 0)
        .pKeyCtrl = IIf(chkCtrl.Value, MOD_CONTROL, 0)
        .pKeyShift = IIf(chkShift.Value, MOD_SHIFT, 0)
        .pKey = Asc(cmbKey.Text)
        .pTargetFile = txtFileName.Text

        lRet = RegisterHotKey(frmIcon.hwnd, intHotKeyCount + 1, vModifierKey, Asc(cmbKey.Text))
    End With
    vModifierKey = ""
    If lRet = 1 Then
        With objPLKeys
            Set lstItem = lstvwPrograms.ListItems.Add(Text:=CommonDialog1.FileTitle) ', Index:=.pHotKeyID
            lstItem.ListSubItems.Add Text:=fnFilefolder(txtFileName.Text, 2)
            lstItem.ListSubItems.Add Text:=sKeys
        End With
        prcWrite
    Else
        frmMsg.Label1.BackColor = vbRed
        prcShowMsg "Unable to save hotkey. GetLastError returned: " & GetLastError
    End If
    chkWin.Value = 0
    chkAlt.Value = 0
    chkCtrl.Value = 0
    chkShift.Value = 0
    txtFileName.Text = ""
End Sub

Private Sub cmdFolder_Click()
Dim myShell As New Shell
Dim myFolder As Folder
Set myFolder = myShell.BrowseForFolder(Me.hwnd, "Select folder", 16)
If Not myFolder Is Nothing Then
    txtFileName.Text = myFolder.Items.Item.Path
End If
CommonDialog1.FileName = ""
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    blnDrag = True
    lTop = Y
    lLeft = X
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If blnDrag Then
        Me.Top = Me.Top + (Y - lTop)
        Me.Left = Me.Left + (X - lLeft)
    End If
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    blnDrag = False
End Sub

Private Sub Form_Load()
Dim intOldMode As Integer

    'to make this form always on top
    Call SetWindowPos(hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)

    '**** TO HIDE THE TITLE BAR ******
    SetWindowLong frmMain.hwnd, GWL_STYLE, GetWindowLong(frmMain.hwnd, GWL_STYLE) And Not WS_CAPTION
    intOldMode = frmMain.ScaleMode
    frmMain.ScaleMode = 1
    frmMain.Height = frmMain.Height - 300
    frmMain.ScaleMode = intOldMode
    '*********************************
    lstvwPrograms.ColumnHeaders.Add Text:="File/Folder", Width:=1340
    lstvwPrograms.ColumnHeaders.Add Text:="Path", Width:=3000
    lstvwPrograms.ColumnHeaders.Add Text:="Shortcut key", Width:=1530

    With cmbKey
        .AddItem ""
        For intIndex = 65 To 90
            .AddItem Chr(intIndex)
        Next
        For intIndex = 48 To 57
            .AddItem Chr(intIndex)
        Next
    End With
    intIndex = 0
    prcLoadData
    prcColorForm Me

    Me.Left = Screen.Width - Me.Width
    Me.Top = Screen.Height - Me.Height
    Me.Refresh
    Me.Visible = True
End Sub

Private Sub prcLoadData()
'this procedure is to load the hotkey details from data.dat into listview
Dim lstItem As ListItem
Dim strText As String

    lstvwPrograms.ListItems.Clear
    intIndex = 1
    Open strDataFile For Random Access Read As #1 'binary file access
    With objPLKeys
    Do
        Get #1, intIndex, objPLKeys  'read from file. read one record at a time
        If .pKey = 0 Then Exit Do 'there are no more records in file

        strText = fnFilefolder(.pTargetFile, 1)
        Set lstItem = lstvwPrograms.ListItems.Add(Text:=strText) ', Index:=.pHotKeyID

        strText = fnFilefolder(.pTargetFile, 2)
        lstItem.ListSubItems.Add Text:=strText
        strText = ""
        If .pKeyWin = MOD_WIN Then
            strText = "Win"
        End If
        If .pKeyCtrl = MOD_CONTROL Then
            strText = strText & IIf(strText = "", "Ctrl", "+Ctrl")
        End If
        If .pKeyShift = MOD_SHIFT Then
            strText = strText & IIf(strText = "", "Shift", "+Shift")
        End If
        If .pKeyAlt = MOD_ALT Then
            strText = strText & IIf(strText = "", "Alt", "+Alt")
        End If
        strText = strText & "+" & Chr(.pKey)
        lstItem.ListSubItems.Add Text:=strText
        intIndex = intIndex + 1
    Loop While True
    End With
    Close #1
End Sub

Private Sub prcWrite()
Dim intRecNo As Integer
Dim strKeys As String
    intRecNo = 1
    'to read record by record from binary file, use only structures.
    'use an instance of a structure to write to file.
    Open strDataFile For Random As #1 'binary file access
    With lstvwPrograms.ListItems
    intHotKeyCount = 0
    For intIndex = 1 To .Count
        strKeys = UCase(.Item(intIndex).ListSubItems(2).Text) 'hotkeys available in listview

        With objPLKeys
'            .pHotKeyID = intIndex
            If InStr(1, strKeys, "WIN", vbTextCompare) <> 0 Then .pKeyWin = MOD_WIN Else .pKeyWin = 0
            If InStr(1, strKeys, "CTRL", vbTextCompare) <> 0 Then .pKeyCtrl = MOD_CONTROL Else .pKeyCtrl = 0
            If InStr(1, strKeys, "SHIFT", vbTextCompare) <> 0 Then .pKeyShift = MOD_SHIFT Else .pKeyShift = 0
            If InStr(1, strKeys, "ALT", vbTextCompare) <> 0 Then .pKeyAlt = MOD_ALT Else .pKeyAlt = 0
            .pKey = Asc(Right(strKeys, 1))
            With lstvwPrograms.ListItems.Item(intIndex)
                objPLKeys.pTargetFile = .ListSubItems(1).Text & IIf(.Text = "", "", "\" & .Text)
            End With
        End With

        Put #1, intIndex, objPLKeys 'write struct to file
        intHotKeyCount = intHotKeyCount + 1
    Next
    End With
    Close #1
End Sub

Private Sub optUser_Click()
    Picture1.SetFocus
End Sub

Private Sub optPredefined_Click()
    Picture1.SetFocus
End Sub

'to retrieve file name or folder from complete path and filename
Private Function fnFilefolder(sz As String, i As Integer) As String
Dim strText As String
Dim intSlashPos As Long
    strText = StrReverse(Trim(sz))
    If InStr(1, strText, ".", vbTextCompare) = 0 Then
        'string does not have '.', its folder name
        If i = 1 Then
            strText = ""
        Else
            strText = sz
        End If
    Else
        'string does have '.', its file name
        'folder name also have have '.', in that case,
        'it wud be difficult to seperate path and file name
        'so, that cannot be handled

        intSlashPos = InStr(1, strText, "\", vbTextCompare)
        If i = 1 Then
            'return path
            strText = StrReverse(Left(strText, intSlashPos - 1))
        ElseIf i = 2 Then
            'return file name
            strText = StrReverse(Mid(strText, intSlashPos + 1))
        End If
    End If
    fnFilefolder = strText
End Function